home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / lib / unittest.scm < prev   
Encoding:
Text File  |  2010-11-07  |  9.6 KB  |  331 lines
  1. ;;  Filename : unittest.scm
  2. ;;  About    : Simple unit test library
  3. ;;
  4. ;;  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
  5. ;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
  6. ;;
  7. ;;  All rights reserved.
  8. ;;
  9. ;;  Redistribution and use in source and binary forms, with or without
  10. ;;  modification, are permitted provided that the following conditions
  11. ;;  are met:
  12. ;;
  13. ;;  1. Redistributions of source code must retain the above copyright
  14. ;;     notice, this list of conditions and the following disclaimer.
  15. ;;  2. Redistributions in binary form must reproduce the above copyright
  16. ;;     notice, this list of conditions and the following disclaimer in the
  17. ;;     documentation and/or other materials provided with the distribution.
  18. ;;  3. Neither the name of authors nor the names of its contributors
  19. ;;     may be used to endorse or promote products derived from this software
  20. ;;     without specific prior written permission.
  21. ;;
  22. ;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
  23. ;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
  24. ;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  25. ;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  26. ;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  27. ;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  28. ;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  29. ;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  30. ;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  31. ;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  32. ;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  33.  
  34. ;; This unit-testing library should be replaced with standard SRFI-64 once the
  35. ;; hygienic-macros are well-implemented. To write new tests, use the SRFI-64
  36. ;; compatible assertions contained at the bottom of this file.
  37. ;;   -- YamaKen 2007-09-01
  38.  
  39. (cond-expand
  40.  (sigscheme
  41.   ;; To allow --disable-srfi55, don't use require-extension here.
  42.   (%%require-module "srfi-6")
  43.   (%%require-module "srfi-23")
  44.   (%%require-module "srfi-34"))
  45.  (else))
  46.  
  47. (define *test-track-progress* #f)  ;; for locating SEGV point
  48. (define *total-testsuites* 1)  ;; TODO: introduce test suites and defaults to 0
  49. (define *total-testcases* 1)   ;; TODO: introduce testcase and defaults to 0
  50. (define *total-tests* 1)       ;; TODO: introduce test group and defaults to 0
  51. (define *total-failures*  0)
  52. (define *total-assertions* 0)
  53. (define *total-errors* 0) ;; TODO: recover unintended error and increment this
  54. (define test-filename "unspecified")
  55.  
  56. (define test-display-result
  57.   (lambda ()
  58.     (let ((header (if (zero? *total-failures*)
  59.                       "OK: "
  60.                       "FAILED: "))
  61.           (total-successes (- *total-assertions* *total-failures*)))
  62.       (for-each display
  63.                 (list
  64.                  header
  65.                  *total-tests*      " tests, "
  66.                  *total-assertions* " assertions, "
  67.                  total-successes    " successes, "
  68.                  *total-failures*   " failures, "
  69.                  *total-errors*     " errors"))
  70.       (newline))))
  71.  
  72. (define test-report-result
  73.   (lambda ()
  74.     (test-display-result)
  75.     (let ((EX_OK       0)
  76.           (EX_SOFTWARE 70))
  77.       (exit (if (positive? *total-failures*)
  78.                 EX_SOFTWARE
  79.                 EX_OK)))))
  80.  
  81. ;; Backward compatibility
  82. (define total-report test-report-result)
  83.  
  84. (define report-error
  85.   (lambda (err-msg)
  86.     (begin
  87.       (display "failed: ")
  88.       (display err-msg)
  89.       (newline))))
  90.  
  91. (define report-inequality
  92.   (lambda (expected actual)
  93.     (display " expected: <")
  94.     (write expected)
  95.     (display ">")
  96.     (newline)
  97.     (display "   actual: <")
  98.     (write actual)
  99.     (display ">")
  100.     (newline)))
  101.  
  102. (define assert
  103.   (let ((+ +))  ;; protect from redefinition
  104.     (lambda (test-name err-msg exp)
  105.       (set! *total-assertions* (+ *total-assertions* 1))
  106.       (if *test-track-progress*
  107.           (begin
  108.             (display "done: ")
  109.             (display test-name)
  110.             (newline)))
  111.       (if exp
  112.           #t
  113.           (begin
  114.             (set! *total-failures* (+ *total-failures* 1))
  115.             (report-error err-msg)
  116.             #f)))))
  117.  
  118. (define test-skip
  119.   (lambda (reason)
  120.     (display "SKIP: ")
  121.     (display reason)
  122.     (newline)
  123.     (exit 77)))  ;; special code for automake
  124.  
  125. ;;
  126. ;; assertions for test writers
  127. ;;
  128.  
  129. (define assert-fail
  130.   (lambda (test-name err-msg)
  131.     (assert test-name err-msg #f)))
  132.  
  133. (define assert-true
  134.   (lambda (test-name exp)
  135.     (assert test-name test-name exp)))
  136.  
  137. (define assert-false
  138.   (lambda (test-name exp)
  139.     (assert test-name test-name (not exp))))
  140.  
  141. (define assert-eq?
  142.   (lambda (test-name expected actual)
  143.     (or (assert test-name test-name (eq? expected actual))
  144.         (report-inequality expected actual))))
  145.  
  146. (define assert-equal?
  147.   (lambda (test-name expected actual)
  148.     (or (assert test-name test-name (equal? expected actual))
  149.         (report-inequality expected actual))))
  150.  
  151. (define assert-error
  152.   (lambda (test-name proc)
  153.     (or (procedure? proc)
  154.         (error "assert-error: procedure required but got" proc))
  155.     (let ((errored (guard (err
  156.                            (else
  157.                             #t))
  158.                      (proc)
  159.                      #f))
  160.           (err-msg (string-append "no error has occurred in test "
  161.                                   test-name)))
  162.       (assert test-name err-msg errored))))
  163.  
  164. (define assert-parse-error
  165.   (lambda (test-name str)
  166.     (assert-error test-name (lambda ()
  167.                               (string-read str)))))
  168.  
  169. (define assert-parseable
  170.   (lambda (test-name str)
  171.     (assert-true test-name (guard (err
  172.                                    (else
  173.                                     #f))
  174.                              (string-read str)
  175.                              #t))))
  176.  
  177. ;;
  178. ;; misc
  179. ;;
  180.  
  181. ;; SigScheme and Gauche surely returns #<undef>
  182. (define undef
  183.   (lambda ()
  184.     (for-each values '())))
  185.  
  186. ;; SigScheme and Gauche surely returns #<eof>
  187. (define eof
  188.   (lambda ()
  189.     (string-read "")))
  190.  
  191. (define obj->literal
  192.   (lambda (obj)
  193.     (let ((port (open-output-string)))
  194.       (write obj port)
  195.       (get-output-string port))))
  196.  
  197. (define string-read
  198.   (lambda (str)
  199.     (let ((port (open-input-string str)))
  200.       (read port))))
  201.  
  202. (define string-eval
  203.   (lambda (str)
  204.     (eval (string-read str)
  205.           (interaction-environment))))
  206.  
  207. (define test-name
  208.   (let ((name "anonymous test")
  209.         (serial 0)
  210.         (+ +))  ;; protect from redefinition
  211.     (lambda args
  212.       (if (null? args)
  213.           (begin
  214.             (set! serial (+ serial 1))
  215.             (string-append name " #" (number->string serial)))
  216.           (begin
  217.             (set! name (car args))
  218.             (set! serial 0)
  219.             #f)))))
  220.  
  221. (define print-expected
  222.   (lambda (expected)
  223.     (display " expected print: ")
  224.     (display expected)
  225.     (newline)
  226.     (display "   actual print: ")))
  227.  
  228.  
  229. ;;
  230. ;; implementation information
  231. ;;
  232.  
  233. (define sigscheme? (provided? "sigscheme"))
  234.  
  235. (define fixnum-bits (and (symbol-bound? 'fixnum-width)
  236.                          (fixnum-width)))
  237.  
  238.  
  239. ;;
  240. ;; SRFI-64 compatibilities
  241. ;;
  242.  
  243. ;; See test-unittest.scm to understand how to use these.
  244.  
  245. (cond-expand
  246.  (sigscheme
  247.   ;; To allow --disable-srfi55, don't use require-extension here.
  248.   (%%require-module "sscm-ext"))
  249.  (else))
  250.  
  251. (define-macro test-begin
  252.     (lambda (suite-name . opt-count)
  253.       (let-optionals* opt-count ((count #f))
  254.         `(test-name ,suite-name))))
  255.  
  256. (define-macro test-end
  257.   (lambda args
  258.     (let-optionals* args ((suite-name #f))
  259.       '#f)))
  260.  
  261. (define-macro test-assert
  262.   (lambda (first . rest)
  263.     (let-optionals* (reverse (cons first rest)) ((expr #f)
  264.                                                  (tname '(test-name)))
  265.       `(assert-true ,tname ,expr))))
  266.  
  267. (define-macro test-equal
  268.   (lambda args
  269.     `(%test-equal equal? . ,args)))
  270.  
  271. (define-macro test-eqv
  272.   (lambda args
  273.     `(%test-equal eqv? . ,args)))
  274.  
  275. (define-macro test-eq
  276.   (lambda args
  277.     `(%test-equal eq? . ,args)))
  278.  
  279. (define-macro %test-equal
  280.   (lambda (= second third . rest)
  281.     (let-optionals* (if (null? rest)
  282.                         (list '(test-name) second third)
  283.                         (cons second (cons third rest)))
  284.         ((tname #f)
  285.          (expected #f)
  286.          (expr #f))
  287.       `(%test-equal2 ,= ,tname ,expected ,expr))))
  288.  
  289. (define %test-equal2
  290.   (lambda (= tname expected actual)
  291.     (or (assert tname tname (= expected actual))
  292.         (report-inequality expected actual))))
  293.  
  294. (define-macro test-error
  295.   (lambda (first . rest)
  296.     (let-optionals* (reverse (cons first rest)) ((expr #f)
  297.                                                  (err-type #t)
  298.                                                  (tname '(test-name)))
  299.       `(assert-error ,tname
  300.                      (lambda ()
  301.                        (eval ',expr (interaction-environment)))))))
  302.  
  303. (define test-read-eval-string
  304.   (lambda (str)
  305.     (let* ((port (open-input-string str))
  306.            (expr (read port)))
  307.       (if (or (eof-object? expr)
  308.               (guard (err
  309.                       (else #t))
  310.                 (not (eof-object? (read-char port)))))
  311.           (error "invalid expression string" str))
  312.       (eval expr (interaction-environment)))))
  313.  
  314.  
  315. ;;
  316. ;; Non-standard SRFI-64-like assertions
  317. ;;
  318.  
  319. ;; I think that writing (test-assert <exp>) and (test-assert (not <exp>)) is
  320. ;; cumbersome.  -- YamaKen 2007-09-04
  321.  
  322. (define-macro test-true
  323.   (lambda args
  324.     `(test-assert . ,args)))
  325.  
  326. (define-macro test-false
  327.   (lambda (first . rest)
  328.     (let-optionals* (reverse (cons first rest)) ((expr #f)
  329.                                                  (tname '(test-name)))
  330.       `(test-assert ,tname (not ,expr)))))
  331.